perm filename PCALL.SAI[PNT,HE]3 blob
sn#472662 filedate 1979-09-05 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00011 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 ENTRY
C00003 00003 ! readcode,editcode
C00008 00004 ! photocall,helpcall
C00014 00005 ! editcall,renamecall
C00018 00006 ! readcall,renmcall,writecall
C00021 00007 ! display: update,arrow,displaycall,redisplaycall,showcall,nodisplaycall
C00027 00008 ! graphcall
C00028 00009 ! eeditcall
C00030 00010 ! deletecall,definecall,notavailcall,exitcall
C00041 00011 ! bailcall,setstatuscall,readmesscall,stopmesscall
C00045 ENDMK
C⊗;
ENTRY;
BEGIN "PCALL"
COMMENT routines which are not available in AL;
DEFINE $PCALL=TRUE;
REQUIRE "HEADER.SAI" SOURCE_FILE;
PROCEDURE TOPLEVEL_PROCEDURE(STRING S);
IF $COMPILE≠0 THEN
ERROR(S&" cannot be used inside a block, only at toplevel");
RCLASS SYMLIST(RPTR(SYMBOL)PTR; RPTR(SYMLIST)NEXT);
! readcode,editcode;
INTERNAL PROCEDURE READCODE(STRING FID; BOOLEAN ECHO(FALSE));
BEGIN
$INPCH←OREADFILE(FID,$EOF);
PUSHDEVSTACK;
IFC #DISPL THENC $ALLOW←$ALLOW+1; IF ECHO THEN DPYFREE; ENDC
DEVICE←DSK_X;
NEWFILE←TRUE; FILEPRINT←ECHO;
END;
! photocall,helpcall;
! manages terminal output. If there is already a file, closes it
and opens another one ;
INTERNAL PROCEDURE PHOTOCALL;
BEGIN
STRING FILE;
TOPLEVEL_PROCEDURE("PHOTO:");
FILE←NAMEFILE;
! SEMICOL_READ; ! commented out for cleaning;
IFC #OUTPT THENC TTYSAVE(FILE); ENDC ! file status modified;
$OULST←NULL;
END;
INTERNAL PROCEDURE HELPCALL;
HELP;
! editcall,renamecall;
RPTR(SYMBOL) $VAR; ! sticky argument for EDITCALL;
RPTR(EXPR$) $VAREXPR;
INTERNAL PROCEDURE EDITCALL;
BEGIN
BOOLEAN DEFAULT;
TOPLEVEL_PROCEDURE("EDIT:");
NOEXPAND←TRUE; ! prevent macro name being expanded ;
GTOKEN(FALSE); ! in case he left out the argument ;
DEFAULT←FALSE;
IF FINAL THEN DEFAULT←TRUE
ELSE IF TOKENPTR=NULL_RECORD THEN ERROR("Unknown identifier")
ELSE $VAR←TOKENPTR;
IF SYMBOL:TYPE[$VAR]=#MC
THEN BEGIN
INTEGER BRCHAR;
STRING OLD_STRING,NEW_STRING,LINE_STRING;
OLD_STRING← "REDEFINE "&MACRO:HEAD[SYMBOL:OBJECT[$VAR]]
&" = "&CVSYM($VAR,EDIT_D)&";";
NEW_STRING←LINE_STRING←NULL;
WHILE OLD_STRING DO
BEGIN LINE_STRING←SCAN(OLD_STRING,$CRTAB,BRCHAR);
LODED(LINE_STRING&CR);
NEW_STRING←NEW_STRING&INCHWL&CRLF;
END;
ASKUSER(NEW_STRING);
END
ELSE
BEGIN
RPTR(EXPR$)E; RPTR(SYMBOL)S;INTEGER TYPE;
IF (TYPE←SYMBOL:TYPE[$VAR])=#PR OR (TYPE=#EV) OR (TYPE=#CM)
THEN ERROR("Cant edit "&$DTYPE[TYPE]&" yet")
ELSE IF PRDECL($VAR)
THEN ERROR(SYMBOL:PNAME[$VAR]," is a POINTY defined variable or constant and cannot be changed")
ELSE IF SYMBOL:ACCESS[$VAR]=#ARRAY
THEN ERROR("Cant edit array elements yet");
IF NOT DEFAULT THEN
BEGIN STOKEN←TRUE; $VAREXPR←IDREF(S); $VAR←S; END;
SEMICOL_READ; ! leave there to avoid troubles;
PRINT("value of ",SYMBOL:PNAME[$VAR]," = ");
LODED(CVEXPR($VAREXPR,EDIT_D)&CR);
ASKUSER;
ASGEX2($VAR,$VAREXPR);
END;
NOEXPAND ← FALSE;
END;
INTERNAL PROCEDURE RENAMCALL;
BEGIN
STRING NEW; RPTR(SYMBOL) TPTR;
TOPLEVEL_PROCEDURE("RENAME:");
NOEXPAND←TRUE;
GTOKEN;
IF #TOKEN≠UNDECLARED_TYPE THEN ERROR("RENAME: Need undeclared token");
NEW←TOKEN;
WORD_READ("←");
GTOKEN;
IF #TOKEN≠ID_TYPE OR SYMBOL:ACCESS[TPTR←TOKENPTR]≠#SIMPLE THEN ERROR
("RENAME: can only change names of simple variables currently");
! SEMICOL_READ; ! commented out for cleaning;
SYMBOL:PNAME[TPTR]←NEW; ! changes the name in record symbol;
IF SYMBOL:TYPE[TPTR]=#FR
THEN FRAME:PNAME[SYMBOL:OBJECT[TPTR]]←NEW;
$DISPLAYLIST[SYMBOL:TYPE[TPTR]]←NULL;
NOEXPAND ← FALSE;
END;
! readcall,renmcall,writecall;
IFC #OUTPT THENC
INTERNAL PROCEDURE READCALL(BOOLEAN ECHO(TRUE));
BEGIN
STRING FILE;
TOPLEVEL_PROCEDURE("READ:");
FILE←"DECLAR.AL"; ! default value;
NOEXPAND←TRUE;
GTOKEN(FALSE);
IF NOT FINAL
THEN BEGIN
STOKEN←TRUE;FILE←NAMEFILE;
! SEMICOL_READ; ! commented out by mlg;
END;
NOEXPAND←FALSE;
READCODE(FILE,ECHO);
END;
INTERNAL PROCEDURE WRITCALL;
BEGIN "A"
STRING FILE;
INTEGER NELEMENTS,I;
RPTR(SYMBOL)ARRAY ELEMENTS[1:20];
TOPLEVEL_PROCEDURE("WRITE");
NELEMENTS←0;
NOEXPAND←TRUE; ! to let through macro names ;
FILE←$ALFL; ! default values;
GTOKEN(FALSE);
IF NOT FINAL
THEN CASE #TOKEN OF
α
[RES_TYPE]
IF EQU(TOKEN,"INTO") THEN STOKEN←TRUE
ELSE IF ¬EQU(TOKEN,"ALL") THEN ERROR("Can't use "&TOKEN&
" as argument to be saved in a write statement");
[ID_TYPE]
DO α
IF (NELEMENTS←NELEMENTS+1)>21 THEN ERROR("Cant output more than 21 elements in one statement");
ELEMENTS[NELEMENTS]←TOKENPTR;
GTOKEN(FALSE);
IF TOKEN="," THEN GTOKEN
ELSE IF FINAL THEN DONE
ELSE STOKEN←TRUE;
β UNTIL #TOKEN≠ID_TYPE;
ELSE ERROR("Can't write out the value of "&TOKEN)
β;
GTOKEN(FALSE);
IF NOT FINAL
THEN IF ¬EQU(TOKEN,"INTO") THEN
ERROR("Need INTO here before putting in file name, but you have got "&token)
ELSE FILE←NAMEFILE;
! SEMICOL_READ; ! commented out for cleaning;
IF NELEMENTS=0 THEN WRITECODE(FILE,NULL_RECORD)
ELSE FOR I←1 STEP 1 UNTIL NELEMENTS DO WRITECODE(FILE,ELEMENTS[I]);
NOEXPAND ← FALSE;
END "A";
ENDC
! display: update,arrow,displaycall,redisplaycall,showcall,nodisplaycall;
IFC ¬ #ARROW THENC
INTERNAL SIMPLE PROCEDURE ARROW; ;
ENDC
IFC #DISPL THENC
INTEGER MDISPLAY; ! display mode;
DEFINE TABLE_DISPLAY=0,
TYPE_DISPLAY=1,
SYMBOL_DISPLAY=2,
NO_DISPLAY=3;
SIMPLE STRING PROCEDURE DEFAULT;
RETURN(" "&OLDCMD&CRLF&" "&OLDOBJ&CRLF);
RCLASS SYMBOL_LIST(RPTR(SYMBOL_LIST)NEXT;RPTR(SYMBOL)PTR);
RPTR(SYMBOL_LIST) DISPLAY_LIST;
INTEGER TDISPLAY;
BOOLEAN NDISPLAY;
PROCEDURE DPYELM(STRING S);
OUTDPW(
"########################### SELECTED VARIABLES ############################"
&crlf&S&crlf&
"###########################################################################",
-3,-2);
PROCEDURE DPYVAR(INTEGER VARTYPE);
IF NOT $DISPLAYLIST[VARTYPE] THEN
OUTDPW(
("************************* CURRENT "&$DTYPE[VARTYPE]&"S ***********************************************")
[1 TO 74]&crlf&($DISPLAYLIST[VARTYPE]←DPY_STRING(VARTYPE))&
"***************************************************************************"
,-3,-3);
PROCEDURE DPYSYMS;
BEGIN STRING S;
RPTR(SYMBOL)SYM;
RPTR(SYMBOL_LIST)SYL;
SYL←DISPLAY_LIST;
S←NULL;
WHILE SYL≠NULL_RECORD
DO BEGIN
S←S&CVSSYM(SYMBOL_LIST:PTR[SYL])&CRLF;
SYL←SYMBOL_LIST:NEXT[SYL];
END;
DPYELM(S);
END;
INTERNAL PROCEDURE UPDATE;
IF $ALLOW=0 THEN $UPDATED←FALSE;
! update the display (if $ALLOW=0);
INTERNAL PROCEDURE RENEW;
BEGIN INTEGER I;
$UPDATED←TRUE;
CASE MDISPLAY OF
BEGIN
[TABLE_DISPLAY]
BEGIN
DPYDRAW;
FOR I←#SC,#VT,#TR,#RT,#FR DO
IF NOT $DISPLAYLIST[I] THEN $DISPLAYLIST[I]←DPY_STRING(I);
IFC #OUTPT THENC IF NOT $OULST THEN $OULST←FILE_STRING;ENDC
$DFLST←DEFAULT;
OUTDPY;
DPYOUT(1);
END;
[NO_DISPLAY]
IF NDISPLAY THEN
BEGIN
OUTDPW(
"**************************** P O I N T Y **********************************
DISPLAY SUPPRESSED; TYPE REDISPLAY TO GET BACK DISPLAY TABLE
TYPE DISPLAY SCALARS TO DISPLAY SCALARS
****************************************************************************
",-3,-2); NDISPLAY←FALSE;
END;
[TYPE_DISPLAY]
DPYVAR(TDISPLAY);
[SYMBOL_DISPLAY]
DPYSYMS
END;
ESC_P;
END;
ENDC
IFC #DISPL THENC
INTERNAL PROCEDURE REDISPLAYCALL;
BEGIN
! SEMICOL_READ; ! commented out for cleaning;
$ALLOW←0;
TDISPLAY←0;
MDISPLAY←TABLE_DISPLAY;
DISPLAY_LIST←NULL_RECORD;
$SCLST←NULL;
END;
INTERNAL PROCEDURE NODISPLAYCALL;
BEGIN
! SUPPRESS DISPLAY;
! SEMICOL_READ; ! commented out for cleaning;
NDISPLAY←TRUE;
MDISPLAY←NO_DISPLAY;
DISPLAY_LIST←NULL_RECORD;
END;
INTERNAL PROCEDURE DISPLAYCALL;
BEGIN
INTEGER TT;
NOEXPAND ← TRUE;
GTOKEN;
IF TOKENPTR ≠ NULL_RECORD
THEN DPYELM(CVSSYM(TOKENPTR))
ELSE BEGIN
FOR TT←#MIN STEP 1 UNTIL #MAX DO
IF EQU(TOKEN,$DTYPE[TT]) OR EQU(TOKEN,$DTYPE[TT]&"S") THEN DONE;
IF TT≤#MAX THEN $DISPLAYLIST[TT]←NULL
ELSE ERROR("No such data type or identifier: "&TOKEN&CRLF);
! SEMICOL_READ; ! commented out for cleaning;
MDISPLAY←TYPE_DISPLAY;
TDISPLAY←TT;
END;
NOEXPAND ← FALSE;
END;
INTERNAL PROCEDURE SHOWCALL;
BEGIN
RPTR(SYMBOL_LIST)SL1,SL2;
NOEXPAND ← TRUE;
SL1←SL2←NEW_RECORD(SYMBOL_LIST);
DO BEGIN
GTOKEN;
IF TOKENPTR=NULL_RECORD
THEN ERROR("SHOW: Need a macro, procedure or variable name after SHOW");
SYMBOL_LIST:NEXT[SL2]←SL2←NEW_RECORD(SYMBOL_LIST);
SYMBOL_LIST:PTR[SL2]←TOKENPTR;
GTOKEN(FALSE);
IF TOKEN≠"," AND NOT FINAL THEN ERROR("Need a comma to separate arguments");
END UNTIL FINAL;
NOEXPAND ← FALSE;
MDISPLAY←SYMBOL_DISPLAY;
DISPLAY_LIST←SYMBOL_LIST:NEXT[SL1];
END;
ENDC
! graphcall;
IFC #GATHER THENC
INTERNAL PROCEDURE GRAPHCALL;
BEGIN
TOPLEVEL_PROCEDURE("GRAPH:");
IF GRAPTR=NULL_RECORD THEN ERROR("GRAPH: no data currently available");
BRK_N;
GRAPH(GRAPHREC:DATA[GRAPTR],
GRAPHREC:CTLBITS[GRAPTR],
GRAPHREC:NPNTS[GRAPTR],
GRAPHREC:SIZE[GRAPTR]);
GRAPTR←NULL_RECORD;
END;
ENDC
! eeditcall;
INTERNAL PROCEDURE EEDITCALL;
BEGIN
RPTR(SYMBOL)EL;INTEGER OBTYPE;STRING FBODY;
RPTR(SCALAR,VECTOR,TRANS,FRAME,ROT,MACRO) TEMP;
STRING VAR;
TOPLEVEL_PROCEDURE("EEDIT:");
NOEXPAND ← TRUE;
VAR←IDF_READ;
SEMICOL_READ;
EL←OLDSYM(VAR,OBTYPE); ! var must exist in $YMTAB;
TEMP←SYMBOL:OBJECT[EL];
IF OBTYPE = #MC
THEN BEGIN
INTEGER BRCHAR;
STRING OLD_STRING;
OLD_STRING← "REDEFINE "&MACRO:HEAD[SYMBOL:OBJECT[EL]]
&" = "&CVSYM(EL,EDIT_D)&";";
SWAP(OLD_STRING);
ASKUSER(OLD_STRING);
ALINIT;
END
ELSE ERROR("EEDIT: only valid for macros");
NOEXPAND ← FALSE;
END;
! deletecall,definecall,notavailcall,exitcall;
INTERNAL PROCEDURE DELETECALL(BOOLEAN QUIET(FALSE));
BEGIN
STRING VAR;
TOPLEVEL_PROCEDURE("DELETE:");
NOEXPAND ← TRUE;
GTOKEN(FALSE);
IF FINAL OR EQU(TOKEN,"ALL")
THEN IF QUIET OR EQU(TOKEN,"ALL") THEN RESET
ELSE BEGIN ! deletes all the variables;
STRING ANSWER;
PRINT("are you sure all variables are to be deleted? ");
ANSWER←INCHRW;
PRINT(CRLF);ESC_P;
IF ANSWER="Y" OR ANSWER="y"
THEN RESET
ELSE ERROR("instruction not executed");
END
ELSE BEGIN "delete elements"
RPTR(SYMLIST)SPTR,SPTR2;
INTEGER #ELEM,I; #ELEM←0;
STOKEN←TRUE; SPTR←SPTR2←NEW_RECORD(SYMLIST);
DO BEGIN "A"
GTOKEN;
IF TOKENPTR THEN
BEGIN
! check if already on the list ;
RPTR(SYMLIST)SPTR3; BOOLEAN FOUND;
IF PRDECL(TOKENPTR) THEN ERROR("DELETE: trying to delete a POINTY declared variable",TOKEN);
SPTR3←SPTR; FOUND←FALSE;
FOR I←1 STEP 1 UNTIL #ELEM DO
IF SYMLIST:PTR[SPTR3]=TOKENPTR THEN FOUND←TRUE
ELSE SPTR3←SYMLIST:NEXT[SPTR3];
IF NOT FOUND THEN
BEGIN
#ELEM←#ELEM+1;
SYMLIST:PTR[SPTR2]←TOKENPTR;
SPTR2←SYMLIST:NEXT[SPTR2]←NEW_RECORD(SYMLIST);
END;
END
ELSE IF NOT QUIET THEN ERROR("DELETE: unknown token ", TOKEN);
GTOKEN(FALSE);
IF TOKEN≠"," AND NOT FINAL THEN ERROR("; or , required");
END "A"
UNTIL FINAL;
FOR I←1 STEP 1 UNTIL #ELEM DO
BEGIN KILLVAR(SYMLIST:PTR[SPTR]);
SPTR←SYMLIST:NEXT[SPTR];
END;
END "delete elements";
NOEXPAND ← FALSE;
END;
INTERNAL PROCEDURE DEFINECALL(BOOLEAN REDEF(FALSE));
BEGIN RPTR(MACRO) MACPTR; STRING MACNAME; INTEGER DDLCOUNT; STRING BODY,NBODY;
! redef is true if it is a redefinition;
INTEGER NPARAM;
NPARAM←0;
NOEXPAND ← TRUE;
GTOKEN;
IF REDEF THEN
BEGIN ! check if it already exists;
IF TOKENPTR=NULL_RECORD OR SYMBOL:TYPE[TOKENPTR]≠#MC
THEN ERROR("REDEFINE: "&TOKEN&" in not a macro name");
MACPTR←SYMBOL:OBJECT[TOKENPTR];
END
ELSE IF #TOKEN ≠ UNDECLARED_TYPE
THEN ERROR("MACRO DEFINITION: need undeclared identifier")
ELSE MACPTR←NEW!RECORD(MACRO);
DDLCOUNT ← 0;
MACNAME ← TOKEN;
GTOKEN;
IF TOKEN≠"("
THEN BEGIN STOKEN←TRUE; MACRO:HEAD[MACPTR]←MACNAME; END
ELSE
BEGIN "parametered macro"
RCLASS PLIST(STRING PARAM; RPTR(PLIST) NEXTP);
RPTR(PLIST) TEMP,TEMP0;
TEMP0←NULL_RECORD;
DO
BEGIN "get parameters"
GTOKEN;
IF #TOKEN ≠ UNDECLARED_TYPE THEN
ERROR("MACRO DEFINITION: need undeclared token for argument");
NPARAM←NPARAM+1;
TEMP←NEW!RECORD(PLIST);
PLIST:NEXTP[TEMP]←TEMP0;
PLIST:PARAM[TEMP]←TOKEN;
TEMP0←TEMP;
GTOKEN;
IF TOKEN≠")" AND TOKEN≠","
THEN ERROR("MACRO DEFINITION: Need comma here");
END "get parameters" UNTIL TOKEN=")";
BEGIN
INTEGER I; STRING ARRAY S[1:NPARAM];
STRING HEAD; HEAD←")";
FOR I←NPARAM STEP -1 UNTIL 1 DO
BEGIN
HEAD←","&(S[I]←PLIST:PARAM[TEMP])&HEAD;
TEMP←PLIST:NEXTP[TEMP];
END;
MEMORY[LOCATION(S)]↔MEMORY[LOCATION(MACRO:PRLIST[MACPTR])];
MACRO:HEAD[MACPTR]←MACNAME&"("&HEAD[2 TO ∞];
END;
MACRO:NPARAM[MACPTR]←NPARAM;
END "parametered macro";
WORD_READ("=");
WORD_READ("⊂"); DDLCOUNT ← 1;
BODY←"⊂";
DO BEGIN
INTEGER I;
I←READTILL("⊂⊃");
BODY←BODY&TOKEN&I;
IF I="⊂"
THEN DDLCOUNT ← DDLCOUNT + 1
ELSE DDLCOUNT ← DDLCOUNT - 1;
END UNTIL DDLCOUNT=0;
BODY←BODY[2 TO ∞-1];
IF NPARAM>0 THEN
BEGIN
NBODY←NULL;
WHILE BODY DO
BEGIN "process the parameters"
INTEGER I;
INTEGER BRCHAR; STRING TTOKEN;
NBODY←NBODY&SCAN(BODY,$LTTAB,BRCHAR);
TTOKEN←SCAN(BODY,$NLTTAB,BRCHAR);
FOR I←1 STEP 1 UNTIL NPARAM
DO IF EQU(MACRO:PRLIST[MACPTR][I],TTOKEN) THEN DONE;
IF I>NPARAM THEN
NBODY←NBODY&TTOKEN
ELSE NBODY←NBODY&DUMMY_DELIM&TTOKEN&DUMMY_DELIM;
END "process the parameters";
END ELSE NBODY←BODY;
MACRO:BODY[MACPTR]←NBODY;
! SEMICOL_READ; ! commented out for cleaning;
IF NOT REDEF THEN ENSYM(MACNAME, #MC, MACPTR);
! enter into symbol table if a define ;
NOEXPAND ← FALSE;
$MCLST←NULL;
END;
ifc false thenc
INTERNAL PROCEDURE DEFINECALL;
BEGIN RPTR(MACRO) MACPTR; STRING MACNAME; INTEGER DDLCOUNT; STRING BODY,NBODY;
INTEGER NPARAM;
NPARAM←0;
NOEXPAND ← TRUE;
GTOKEN;
IF #TOKEN ≠ UNDECLARED_TYPE
THEN ERROR("MACRO DEFINITION: need undeclared identifier");
DDLCOUNT ← 0;
MACPTR ← NEW!RECORD(MACRO);
MACNAME ← TOKEN;
GTOKEN;
IF TOKEN≠"("
THEN BEGIN STOKEN←TRUE; MACRO:HEAD[MACPTR]←MACNAME; END
ELSE
BEGIN "parametered macro"
RCLASS PLIST(STRING PARAM; RPTR(PLIST) NEXTP);
RPTR(PLIST) TEMP,TEMP0;
TEMP0←NULL_RECORD;
DO
BEGIN "get parameters"
GTOKEN;
IF #TOKEN ≠ UNDECLARED_TYPE THEN
ERROR("MACRO DEFINITION: need undeclared token for argument");
NPARAM←NPARAM+1;
TEMP←NEW!RECORD(PLIST);
PLIST:NEXTP[TEMP]←TEMP0;
PLIST:PARAM[TEMP]←TOKEN;
TEMP0←TEMP;
GTOKEN;
IF TOKEN≠")" AND TOKEN≠","
THEN ERROR("MACRO DEFINITION: Need comma here");
END "get parameters" UNTIL TOKEN=")";
BEGIN
INTEGER I; STRING ARRAY S[1:NPARAM];
STRING HEAD; HEAD←")";
FOR I←NPARAM STEP -1 UNTIL 1 DO
BEGIN
HEAD←","&(S[I]←PLIST:PARAM[TEMP])&HEAD;
TEMP←PLIST:NEXTP[TEMP];
END;
MEMORY[LOCATION(S)]↔MEMORY[LOCATION(MACRO:PRLIST[MACPTR])];
MACRO:HEAD[MACPTR]←MACNAME&"("&HEAD[2 TO ∞];
END;
MACRO:NPARAM[MACPTR]←NPARAM;
END "parametered macro";
WORD_READ("=");
WORD_READ("⊂"); DDLCOUNT ← 1;
BODY←"⊂";
DO BEGIN
INTEGER I;
I←READTILL("⊂⊃");
BODY←BODY&TOKEN&I;
IF I="⊂"
THEN DDLCOUNT ← DDLCOUNT + 1
ELSE DDLCOUNT ← DDLCOUNT - 1;
END UNTIL DDLCOUNT=0;
BODY←BODY[2 TO ∞-1];
IF NPARAM>0 THEN
BEGIN
NBODY←NULL;
WHILE BODY DO
BEGIN "process the parameters"
INTEGER I;
INTEGER BRCHAR; STRING TTOKEN;
NBODY←NBODY&SCAN(BODY,$LTTAB,BRCHAR);
TTOKEN←SCAN(BODY,$NLTTAB,BRCHAR);
FOR I←1 STEP 1 UNTIL NPARAM
DO IF EQU(MACRO:PRLIST[MACPTR][I],TTOKEN) THEN DONE;
IF I>NPARAM THEN
NBODY←NBODY&TTOKEN
ELSE NBODY←NBODY&DUMMY_DELIM&TTOKEN&DUMMY_DELIM;
END "process the parameters";
END ELSE NBODY←BODY;
MACRO:BODY[MACPTR]←NBODY;
SEMICOL_READ;
ENSYM(MACNAME, #MC, MACPTR);
NOEXPAND ← FALSE;
$MCLST←NULL;
END;
endc
INTERNAL PROCEDURE NOTAVAILCALL;
BEGIN
PRINT(TOKEN & " " &#VERSION);
OUTSTR("Will flush this statement"&crlf);
DO GTOKEN(FALSE) UNTIL FINAL;
END;
INTERNAL PROCEDURE EXITCALL;
BEGIN
SEMICOL_READ;
ENDIT;
END;
! bailcall,setstatuscall,readmesscall,stopmesscall;
INTERNAL PROCEDURE BAILCALL;
BAILCODE;
INTERNAL PROCEDURE QBLCALL;
QBAILCODE;
INTERNAL PROCEDURE SETSTATUSCALL(INTEGER VARVALUE);
BEGIN
! this procedure is to set the values of certain POINTY system variables
in the SAIL part for program control : it takes a VARIABLE and an integer
and assigns the value of the string to the variable name ;
INTEGER I; STRING VARNAME,PRNAME;
WORD_READ("(");
NOEXPAND←TRUE;
GTOKEN;
VARNAME←TOKEN;
IF VARVALUE=1 THEN PRNAME←"SETSTATUS:" ELSE PRNAME←"RESETSTATUS:";
GTOKEN;
IF TOKEN=","
THEN BEGIN
GTOKEN;
IF #TOKEN≠INT_TYPE THEN ERROR(PRNAME," Need integer argument");
VARVALUE←INTSCAN(TOKEN,I);
END
ELSE STOKEN←TRUE;
IF EQU(VARNAME,"PPCODE") THEN !PPCODE←VARVALUE
ELSE IF EQU(VARNAME,"LINE") THEN !LINE←VARVALUE
ELSE IF EQU(VARNAME,"NOELF") THEN
BEGIN $NOELF←VARVALUE;
IF $ELFUNAVAILABLE THEN ERROR("This is no good. I cant get access to the ELF!!!");
END
ELSE ERROR(PRNAME," valid arguments are PPCODE,LINE,NOELF");
GTOKEN;
IF TOKEN≠")" THEN ERROR(PRNAME," need )");
NOEXPAND←FALSE;
! SEMICOL_READ; ! commented out for cleaning;
END;
INTERNAL PROCEDURE READMESSCALL;
BEGIN
! SEMICOL_READ; ! commented out for cleaning;
PUSHDEVSTACK;
DEVICE←MESSAGE_X;
END;
INTERNAL PROCEDURE STOPMESSCALL;
BEGIN
! SEMICOL_READ; ! commented out for cleaning;
$CLNE←$CLINR←NULL;
POPDEVSTACK;
END;
END "PCALL";